home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / paswiz14.zip / SOURCE.ZIP / EXTMATH.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-20  |  21KB  |  857 lines

  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1993  Thomas G. Hanlin III         |
  4.     |             3544 E. Southern Ave. #104,  Mesa, AZ 85204              |
  5.     |                                                                      |
  6.     |                     The Pascal Wizard's Library                      |
  7.     |                                                                      |
  8.     +----------------------------------------------------------------------+
  9.  
  10.  
  11.  
  12. Extended math:
  13.  
  14.    This unit contains procedures and functions that implement extensions to
  15.    Pascal's built-in math (new trig functions, et al) and an arithmetic
  16.    expression evaluator.  The latter is loosely based on EXPR.C from Dr.
  17.    Dobb's Journal, Sept 1985, p.25.
  18.  
  19. }
  20.  
  21. UNIT ExtMath;
  22.  
  23. INTERFACE
  24.  
  25. FUNCTION ArcCos (Number: Real): Real;
  26. FUNCTION ArcCosH (Number: Real): Real;
  27. FUNCTION ArcCot (Number: Real): Real;
  28. FUNCTION ArcCotH (Number: Real): Real;
  29. FUNCTION ArcCsc (Number: Real): Real;
  30. FUNCTION ArcCscH (Number: Real): Real;
  31. FUNCTION ArcSec (Number: Real): Real;
  32. FUNCTION ArcSecH (Number: Real): Real;
  33. FUNCTION ArcSin (Number: Real): Real;
  34. FUNCTION ArcSinH (Number: Real): Real;
  35. FUNCTION ArcTanH (Number: Real): Real;
  36. FUNCTION Ceil (Number: Real): Real;
  37. FUNCTION CosH (Number: Real): Real;
  38. FUNCTION Cot (Number: Real): Real;
  39. FUNCTION CotH (Number: Real): Real;
  40. FUNCTION Csc (Number: Real): Real;
  41. FUNCTION CscH (Number: Real): Real;
  42. FUNCTION Deg2Rad (Number: Real): Real;
  43. FUNCTION e: Real;
  44. FUNCTION Erf (Number: Real): Real;
  45. FUNCTION Fact (Number: Integer): Real;
  46. FUNCTION Floor (Number: Real): Real;
  47. FUNCTION Log (Number: Real): Real;
  48. FUNCTION Rad2Deg (Number: Real): Real;
  49. FUNCTION Raise (Number: Real; Power: Integer): Real;
  50. FUNCTION Sec (Number: Real): Real;
  51. FUNCTION SecH (Number: Real): Real;
  52. FUNCTION SgnI (Number: Integer): Integer;
  53. FUNCTION SgnR (Number: Real): Integer;
  54. FUNCTION SinH (Number: Real): Real;
  55. FUNCTION Tan (Number: Real): Real;
  56. FUNCTION TanH (Number: Real): Real;
  57.  
  58. PROCEDURE Evaluate (Expr: String; VAR Result: Real; VAR ErrCode: Integer);
  59.  
  60.  
  61.  
  62. { --------------------------------------------------------------------------- }
  63.  
  64.  
  65.  
  66. IMPLEMENTATION
  67.  
  68. { forward declarations for the Evaluate procedure }
  69. FUNCTION Eval (VAR Expr: String; VAR ErrCode: Integer): Real; FORWARD;
  70. FUNCTION Factor (VAR Expr: String; VAR ErrCode: Integer): Real; FORWARD;
  71. FUNCTION IsDigit (Expr: String): Boolean; FORWARD;
  72. FUNCTION Locase (Ch: Char): Char; FORWARD;
  73. FUNCTION ParensOk (Expr: String): Boolean; FORWARD;
  74. FUNCTION Term (VAR Expr: String; VAR ErrCode: Integer): Real; FORWARD;
  75. PROCEDURE AddParen (VAR Expr: String; Posn, WhichWay: Integer); FORWARD;
  76. PROCEDURE FixPrecedence (VAR Expr: String); FORWARD;
  77.  
  78.  
  79.  
  80. { ----- Ceiling ----- }
  81. FUNCTION Ceil (Number: Real): Real;
  82. BEGIN
  83.    IF Number = INT(Number) THEN
  84.       Ceil := Number
  85.    ELSE
  86.       Ceil := INT(Number) + 1.0;
  87. END;
  88.  
  89.  
  90.  
  91. { ----- Floor ----- }
  92. FUNCTION Floor (Number: Real): Real;
  93. BEGIN
  94.    IF Number = INT(Number) THEN
  95.       Floor := Number
  96.    ELSE
  97.       Floor := INT(Number) - 1.0;
  98. END;
  99.  
  100.  
  101.  
  102. { ----- Inverse cosine ----- }
  103. FUNCTION ArcCos (Number: Real): Real;
  104. BEGIN
  105.    IF (Number < -1.0) OR (Number > 1.0) THEN      { error }
  106.       ArcCos := 99999.0
  107.    ELSE
  108.       ArcCos := PI / 2.0 - ArcSin(Number);
  109. END;
  110.  
  111.  
  112.  
  113. { ----- Inverse hyperbolic cosine ----- }
  114. FUNCTION ArcCosH (Number: Real): Real;
  115. BEGIN
  116.    ArcCosH := Log(Number + SQRT(SQR(Number) - 1.0));
  117. END;
  118.  
  119.  
  120.  
  121. { ----- Inverse cotangent ----- }
  122. FUNCTION ArcCot (Number: Real): Real;
  123. BEGIN
  124.    ArcCot := -ARCTAN(Number) + PI / 2.0;
  125. END;
  126.  
  127.  
  128.  
  129. { ----- Inverse hyperbolic cotangent ----- }
  130. FUNCTION ArcCotH (Number: Real): Real;
  131. BEGIN
  132.    ArcCotH := LN((Number + 1.0) / (Number - 1.0)) / 2.0;
  133. END;
  134.  
  135.  
  136.  
  137. { ----- Inverse cosecant ----- }
  138. FUNCTION ArcCsc (Number: Real): Real;
  139. BEGIN
  140.    ArcCsc := ARCTAN(1.0 / SQRT(1.0 - SQR(Number)))
  141.       + (SgnR(Number) - 1.0) * (PI / 2.0);
  142. END;
  143.  
  144.  
  145.  
  146. { ----- Inverse hyperbolic cosecant ----- }
  147. FUNCTION ArcCscH (Number: Real): Real;
  148. BEGIN
  149.    ArcCscH := LN((SgnR(Number) * SQRT(SQR(Number) + 1.0) + 1.0) / Number);
  150. END;
  151.  
  152.  
  153.  
  154. { ----- Inverse secant ----- }
  155. FUNCTION ArcSec (Number: Real): Real;
  156. BEGIN
  157.    ArcSec := ARCTAN(Number / SQRT(1.0 - SQR(Number)))
  158.       + (SgnR(Number) - 1.0) * (PI / 2.0);
  159. END;
  160.  
  161.  
  162.  
  163. { ----- Inverse hyperbolic secant ----- }
  164. FUNCTION ArcSecH (Number: Real): Real;
  165. BEGIN
  166.    ArcSecH := LN((SQRT(1.0 - SQR(Number)) + 1.0) / Number);
  167. END;
  168.  
  169.  
  170.  
  171. { ----- Inverse sine ----- }
  172. FUNCTION ArcSin (Number: Real): Real;
  173. VAR
  174.    Negate: Boolean;
  175.    tmp: Real;
  176. BEGIN
  177.    IF Number < 0.0 THEN BEGIN
  178.       Number := -Number;
  179.       Negate := TRUE;
  180.    END
  181.    ELSE
  182.       Negate := FALSE;
  183.    IF Number > 1.0 THEN BEGIN
  184.       tmp := 99999.0;
  185.       Negate := FALSE;
  186.    END
  187.    ELSE BEGIN
  188.       tmp := SQRT(1.0 - SQR(Number));
  189.       IF Number > 0.7 THEN
  190.          tmp := PI / 2.0 - ARCTAN(tmp / Number)
  191.       ELSE
  192.          tmp := ARCTAN(Number / tmp);
  193.    END;
  194.    IF Negate THEN
  195.       ArcSin := -tmp
  196.    ELSE
  197.       ArcSin := tmp;
  198. END;
  199.  
  200.  
  201.  
  202. { ----- Inverse hyperbolic sine ----- }
  203. FUNCTION ArcSinH (Number: Real): Real;
  204. BEGIN
  205.    ArcSinH := Log(Number + SQRT(SQR(Number) + 1.0));
  206. END;
  207.  
  208.  
  209.  
  210. { ----- Inverse hyperbolic tangent ----- }
  211. FUNCTION ArcTanH (Number: Real): Real;
  212. BEGIN
  213.    ArcTanH := Log((1.0 + Number) / (1.0 - Number)) / 2.0;
  214. END;
  215.  
  216.  
  217.  
  218. { ----- Convert degrees to radians ----- }
  219. FUNCTION Deg2Rad (Number: Real): Real;
  220. BEGIN
  221.    Deg2Rad := Number * PI / 180.0;
  222. END;
  223.  
  224.  
  225.  
  226. { ----- e (base of the natural logarithms) ----- }
  227. FUNCTION e: Real;
  228. BEGIN
  229.    e := 2.7182818284590452353602874713526624977572470936999595749669676;
  230. END;
  231.  
  232.  
  233.  
  234. { ----- Hyperbolic cosine ----- }
  235. FUNCTION CosH (Number: Real): Real;
  236. BEGIN
  237.    IF Number < 0.0 THEN
  238.       Number := - Number;
  239.    IF Number > 21.0 THEN
  240.       CosH := Exp(Number) / 2.0
  241.    ELSE
  242.       CosH := (Exp(Number) + Exp(-Number)) / 2.0;
  243. END;
  244.  
  245.  
  246.  
  247. { ----- Cotangent ----- }
  248. FUNCTION Cot (Number: Real): Real;
  249. BEGIN
  250.    Cot := 1.0 / Tan(Number);
  251. END;
  252.  
  253.  
  254.  
  255. { ----- Hyperbolic cotangent ----- }
  256. FUNCTION CotH (Number: Real): Real;
  257. VAR
  258.    tmp: REAL;
  259. BEGIN
  260.    tmp := EXP(-Number);
  261.    CotH := tmp / (EXP(Number) - tmp) * 2.0 + 1.0;
  262. END;
  263.  
  264.  
  265.  
  266. { ----- Cosecant ----- }
  267. FUNCTION Csc (Number: Real): Real;
  268. BEGIN
  269.    Csc := 1.0 / Sin(Number);
  270. END;
  271.  
  272.  
  273.  
  274. { ----- Hyperbolic cosecant ----- }
  275. FUNCTION CscH (Number: Real): Real;
  276. BEGIN
  277.    CscH := 2.0 / (EXP(Number) - EXP(-Number));
  278. END;
  279.  
  280.  
  281.  
  282. { ----- Error Function ----- }
  283. FUNCTION Erf (Number: Real): Real;
  284. VAR
  285.    J, N: Integer;
  286.    S: Real;
  287. BEGIN
  288.    N := Trunc(14.0 * Number + 3.0);
  289.    S := 1.0 / (2.0 * N - 1.0);
  290.    FOR J := N - 1 DOWNTO 1 DO
  291.       S := 1.0 / (2.0 * J - 1.0) - SQR(Number) / J * S;
  292.    Erf := Number / 0.8862269254527581 * S;
  293. END;
  294.  
  295.  
  296.  
  297. { ----- Factorial ----- }
  298. FUNCTION Fact (Number: Integer): Real;
  299. VAR
  300.    Result: Real;
  301.    tmp: Integer;
  302. BEGIN
  303.    Result := 1.0;
  304.    FOR tmp := 2 TO Number DO
  305.       Result := Result * tmp;
  306.    Fact := Result;
  307. END;
  308.  
  309.  
  310.  
  311. { ----- Logarithm (base 10) ----- }
  312. FUNCTION Log (Number: Real): Real;
  313. BEGIN
  314.    Log := Ln(Number) / Ln(10.0);
  315. END;
  316.  
  317.  
  318.  
  319. { ----- Convert radians to degrees ----- }
  320. FUNCTION Rad2Deg (Number: Real): Real;
  321. BEGIN
  322.    Rad2Deg := Number * 180.0 / PI;
  323. END;
  324.  
  325.  
  326.  
  327. { ----- Raise a number to a power (a feature oddly lacking in Pascal). }
  328. FUNCTION Raise (Number: Real; Power: Integer): Real;
  329. VAR
  330.    tmp: Integer;
  331.    Result: Real;
  332. BEGIN
  333.    Result := 1.0;
  334.    FOR tmp := 1 TO Power DO
  335.       Result := Result * Number;
  336.    Raise := Result;
  337. END;     { Raise }
  338.  
  339.  
  340.  
  341. { ----- Secant ----- }
  342. FUNCTION Sec (Number: Real): Real;
  343. BEGIN
  344.    Sec := 1.0 / Cos(Number);
  345. END;
  346.  
  347.  
  348.  
  349. { ----- Hyperbolic secant ----- }
  350. FUNCTION SecH (Number: Real): Real;
  351. BEGIN
  352.    SecH := 2.0 / (EXP(Number) + EXP(-Number));
  353. END;
  354.  
  355.  
  356.  
  357. { ----- Signum (integer) ----- }
  358. FUNCTION SgnI (Number: Integer): Integer;
  359. BEGIN
  360.    IF Number < 0 THEN
  361.       SgnI := -1
  362.    ELSE IF Number > 0 THEN
  363.       SgnI := 1
  364.    ELSE
  365.       SgnI := 0;
  366. END;
  367.  
  368.  
  369.  
  370. { ----- Signum (real) ----- }
  371. FUNCTION SgnR (Number: Real): Integer;
  372. BEGIN
  373.    IF Number < 0.0 THEN
  374.       SgnR := -1
  375.    ELSE IF Number > 0.0 THEN
  376.       SgnR := 1
  377.    ELSE
  378.       SgnR := 0;
  379. END;
  380.  
  381.  
  382.  
  383. { ----- Hyperbolic sine ----- }
  384. FUNCTION SinH (Number: Real): Real;
  385. VAR
  386.    Negate: Boolean;
  387.    p0, p1, p2, p3, q0, q1, q2, tmp, tmp1, tmp2, tmpsq: Real;
  388. BEGIN
  389.    p0 := -630767.3640497716991184787251;
  390.    p1 := -89912.72022039509355398013511;
  391.    p2 := -2894.211355989563807284660366;
  392.    p3 := -26.30563213397497062819489;
  393.    q0 := -630767.3640497716991212077277;
  394.    q1 := 15215.17378790019070696485176;
  395.    q2 := -173.678953558233699533450911;
  396.    IF Number < 0.0 THEN BEGIN
  397.       Number := -Number;
  398.       Negate := TRUE;
  399.    END
  400.    ELSE
  401.       Negate := FALSE;
  402.    IF Number > 21.0 THEN
  403.       tmp := Exp(Number) / 2.0
  404.    ELSE IF Number > 0.5 THEN
  405.       tmp := (Exp(Number) - Exp(-Number)) / 2.0
  406.    ELSE BEGIN
  407.       tmpsq := SQR(Number);
  408.       tmp1 := (((tmpsq * p3 + p2) * tmpsq + p1) * tmpsq + p0) * Number;
  409.       tmp2 := ((tmpsq + q2) * tmpsq + q1) * tmpsq + q0;
  410.       tmp := tmp1 / tmp2;
  411.    END;
  412.    IF Negate THEN
  413.       SinH := -tmp
  414.    ELSE
  415.       SinH := tmp;
  416. END;
  417.  
  418.  
  419.  
  420. { ----- Tangent ----- }
  421. FUNCTION Tan (Number: Real): Real;
  422. BEGIN
  423.    Tan := Sin(Number) / Cos(Number);
  424. END;
  425.  
  426.  
  427.  
  428. { ----- Hyperbolic tangent ----- }
  429. FUNCTION TanH (Number: Real): Real;
  430. VAR
  431.    Negate: Boolean;
  432.    tmp: Real;
  433. BEGIN
  434.    IF Number < 0.0 THEN BEGIN
  435.       Number := -Number;
  436.       Negate := TRUE;
  437.    END
  438.    ELSE
  439.       Negate := FALSE;
  440.    IF Number > 21.0 THEN     { error }
  441.       TanH := 99999
  442.    ELSE BEGIN
  443.       tmp := SinH(Number) / CosH(Number);
  444.       IF Negate THEN
  445.          TanH := -tmp
  446.       ELSE
  447.          TanH := tmp;
  448.    END;
  449. END;
  450.  
  451.  
  452.  
  453. { =========================================================================== }
  454.  
  455.  
  456.  
  457. { ----- This is the main evaluation routine ----- }
  458. PROCEDURE Evaluate (Expr: String; VAR Result: Real; VAR ErrCode: Integer);
  459. VAR
  460.    tmp: Integer;
  461. BEGIN
  462.    WHILE (Pos(' ', Expr) > 0) DO
  463.       Delete(Expr, Pos(' ', Expr), 1);
  464.    WHILE (Pos('**', Expr) > 0) DO BEGIN
  465.       tmp := Pos('**', Expr);
  466.       Delete(Expr, tmp, 1);
  467.       Expr[tmp] := '^';
  468.    END;
  469.    IF Length(Expr) > 0 THEN
  470.       IF ParensOk(Expr) THEN BEGIN
  471.          FOR tmp := 1 TO Length(Expr) DO
  472.             Expr[tmp] := Upcase(Expr[tmp]);
  473.          ErrCode := 0;
  474.          FixPrecedence(Expr);
  475.          Result := Eval(Expr, ErrCode);
  476.       END
  477.       ELSE
  478.          ErrCode := 4
  479.    ELSE
  480.       ErrCode := 8;
  481. END;     { Evaluate }
  482.  
  483.  
  484.  
  485. { ----- This adds parentheses to force evaluation by normal algebraic
  486.         precedence (negation, exponentiation, multiplication and division,
  487.         addition and subtraction) }
  488. PROCEDURE AddParen (VAR Expr: String; Posn, WhichWay: Integer);
  489. VAR
  490.    Done: Boolean;
  491.    ch: Char;
  492.    Depth: Integer;
  493. BEGIN
  494.    Done := FALSE;
  495.    IF WhichWay < 0 THEN BEGIN
  496.       REPEAT
  497.          Dec(Posn);
  498.          IF Posn < 1 THEN BEGIN
  499.             Expr := '(' + Expr;
  500.             Done := TRUE;
  501.          END
  502.          ELSE BEGIN
  503.             ch := Expr[Posn];
  504.             IF Pos(ch, '^*/+-') > 0 THEN BEGIN
  505.                Insert('(', Expr, Posn + 1);
  506.                Done := TRUE;
  507.             END
  508.             ELSE IF ch = ')' THEN BEGIN
  509.                Depth := 1;
  510.                REPEAT
  511.                   Dec(Posn);
  512.                   IF Posn > 0 THEN BEGIN
  513.                      ch := Expr[Posn];
  514.                      IF ch = '(' THEN
  515.                         Dec(Depth)
  516.                      ELSE IF ch = ')' THEN
  517.                         Inc(Depth);
  518.                   END
  519.                   ELSE
  520.                      Depth := 0;
  521.                UNTIL Depth = 0;
  522.                IF Posn < 1 THEN
  523.                   Posn := 1;
  524.                Insert('(', Expr, Posn + 1);
  525.                Done := TRUE;
  526.             END;
  527.          END;
  528.       UNTIL Done;
  529.    END
  530.    ELSE
  531.       REPEAT
  532.          Inc(Posn);
  533.          IF Posn > Length(Expr) THEN BEGIN
  534.             Expr := Expr + ')';
  535.             Done := TRUE;
  536.          END
  537.          ELSE BEGIN
  538.             ch := Expr[Posn];
  539.             IF Pos(ch, '^*/+-') > 0 THEN BEGIN
  540.                Insert(')', Expr, Posn);
  541.                Done := TRUE;
  542.             END
  543.             ELSE IF ch = '(' THEN BEGIN
  544.                Depth := 1;
  545.                REPEAT
  546.                   Inc(Posn);
  547.                   IF Posn <= Length(Expr) THEN BEGIN
  548.                      ch := Expr[Posn];
  549.                      IF ch = ')' THEN
  550.                         Dec(Depth)
  551.                      ELSE IF ch = '(' THEN
  552.                         Inc(Depth);
  553.                   END
  554.                   ELSE
  555.                      Depth := 0;
  556.                UNTIL Depth = 0;
  557.                IF Posn > Length(Expr) THEN
  558.                   Posn := Length(Expr);
  559.                Insert(')', Expr, Posn);
  560.                Done := TRUE;
  561.             END;
  562.          END;
  563.       UNTIL Done;
  564. END;    { AddParen }
  565.  
  566.  
  567.  
  568. { ----- This recursive function is the heart of the expression evaluator. }
  569. FUNCTION Eval (VAR Expr: String; VAR ErrCode: Integer): Real;
  570. VAR
  571.    LVal, tmp: Real;
  572. BEGIN
  573.    LVal := Factor(Expr, ErrCode);
  574.    IF ErrCode = 0 THEN
  575.       CASE Expr[1] OF
  576.          '+': BEGIN
  577.                  Delete(Expr, 1, 1);
  578.                  LVal := LVal + Eval(Expr, ErrCode);
  579.               END;
  580.          '-': BEGIN
  581.                  Delete(Expr, 1, 1);
  582.                  LVal := LVal - Eval(Expr, ErrCode);
  583.               END;
  584.          '*': BEGIN
  585.                  Delete(Expr, 1, 1);
  586.                  LVal := LVal * Eval(Expr, ErrCode);
  587.               END;
  588.          '/': BEGIN
  589.                  Delete(Expr, 1, 1);
  590.                  tmp := Eval(Expr, ErrCode);
  591.                  IF ErrCode = 0 THEN
  592.                     IF tmp = 0.0 THEN
  593.                        ErrCode := 9
  594.                     ELSE
  595.                        LVal := LVal / tmp;
  596.               END;
  597.          '^': BEGIN
  598.                  Delete(Expr, 1, 1);
  599.                  LVal := Raise(LVal, Trunc(Eval(Expr, ErrCode)));
  600.               END;
  601.          ')': Delete(Expr, 1, 1);
  602.       END;     { CASE }
  603.    Eval := LVal;
  604. END;     { Eval }
  605.  
  606.  
  607.  
  608. { ----- A recursive evaluation helper, this function gets the leftmost term
  609.         that can be dealt with at this point in the evaluation. }
  610. FUNCTION Factor (VAR Expr: String; VAR ErrCode: Integer): Real;
  611. VAR
  612.    Negate: Boolean;
  613.    RVal: Real;
  614. BEGIN
  615.    RVal := 0.0;
  616.    IF Expr[1] = '-' THEN BEGIN
  617.       Negate := TRUE;
  618.       Delete(Expr, 1, 1);
  619.    END
  620.    ELSE
  621.       Negate := FALSE;
  622.    IF Expr[1] <> '(' THEN
  623.       RVal := Term(Expr, ErrCode)
  624.    ELSE BEGIN
  625.       Delete(Expr, 1, 1);
  626.       RVal := Eval(Expr, ErrCode);
  627.    END;
  628.    IF Negate THEN
  629.       Factor := -RVal
  630.    ELSE
  631.       Factor := RVal;
  632. END;     { Factor }
  633.  
  634.  
  635.  
  636. { ----- Since the evaluation function doesn't naturally evaluate expressions
  637.         using algebraic precedence, but does understand parentheses...
  638.         This routine adds parentheses to force the proper precedence. }
  639. PROCEDURE FixPrecedence (VAR Expr: String);
  640. VAR
  641.    Posn, tmp: Integer;
  642. BEGIN
  643.    Expr := '(' + Expr + ')';
  644.    Posn := 2;
  645.    REPEAT
  646.       IF Expr[Posn] = '-' THEN
  647.          IF NOT(Expr[Posn - 1] IN ['0'..'9','A'..'Z']) THEN BEGIN
  648.             AddParen(Expr, Posn, 1);
  649.             AddParen(Expr, Posn, -1);
  650.             Inc(Posn, 2);
  651.          END
  652.          ELSE
  653.             Inc(Posn)
  654.       ELSE
  655.          Inc(Posn);
  656.    UNTIL Posn > Length(Expr);
  657.    Posn := 1;
  658.    REPEAT
  659.       IF Expr[Posn] <> Locase(Expr[Posn]) THEN BEGIN
  660.          AddParen(Expr, Posn, 1);
  661.          AddParen(Expr, Posn, -1);
  662.          Inc(Posn, 2);
  663.       END
  664.       ELSE
  665.          Inc(Posn);
  666.    UNTIL Posn > Length(Expr);
  667.    Posn := 1;
  668.    REPEAT
  669.       IF Expr[Posn] = '^' THEN BEGIN
  670.          AddParen(Expr, Posn, 1);
  671.          AddParen(Expr, Posn, -1);
  672.          Inc(Posn, 2);
  673.       END
  674.       ELSE
  675.          Inc(Posn);
  676.    UNTIL Posn > Length(Expr);
  677.    Posn := 1;
  678.    REPEAT
  679.       IF Pos(Expr[Posn], '*/') > 0 THEN BEGIN
  680.          AddParen(Expr, Posn, 1);
  681.          AddParen(Expr, Posn, -1);
  682.          Inc(Posn, 2);
  683.       END
  684.       ELSE
  685.          Inc(Posn);
  686.    UNTIL Posn > Length(Expr);
  687.    Posn := 1;
  688.    REPEAT
  689.       IF Pos(Expr[Posn], '+-') > 0 THEN BEGIN
  690.          AddParen(Expr, Posn, 1);
  691.          AddParen(Expr, Posn, -1);
  692.          Inc(Posn, 2);
  693.       END
  694.       ELSE
  695.          Inc(Posn);
  696.    UNTIL Posn > Length(Expr);
  697.    Delete(Expr, 1, 1);
  698.    Delete(Expr, Length(Expr), 1);
  699. END;     { FixPrecedence }
  700.  
  701.  
  702.  
  703. { ----- Determine whether a character may be construed as being numeric. }
  704. FUNCTION IsDigit (Expr: String): Boolean;
  705. BEGIN
  706.    IF Length(Expr) > 0 THEN
  707.       IsDigit := (Pos(Expr[1], '0123456789.') > 0)
  708.    ELSE
  709.       IsDigit := FALSE;
  710. END;     { IsDigit }
  711.  
  712.  
  713.  
  714. { ----- Convert a character to lowercase. }
  715. FUNCTION LoCase (ch: Char): Char;
  716. BEGIN
  717.    IF ch IN ['A'..'Z'] THEN
  718.       LoCase := CHR(ORD(ch) XOR 32)
  719.    ELSE
  720.       LoCase := ch
  721. END;     { LoCase }
  722.  
  723.  
  724.  
  725. { ----- Check to make sure parentheses are balanced. }
  726. FUNCTION ParensOk (Expr: String): Boolean;
  727. VAR
  728.    Parens, Posn: Integer;
  729. BEGIN
  730.    Parens := 0;
  731.    FOR Posn := 1 TO Length(Expr) DO
  732.       IF Expr[Posn] = '(' THEN
  733.          Inc(Parens)
  734.       ELSE IF Expr[Posn] = ')' THEN
  735.          Dec(Parens);
  736.    ParensOk := (Parens = 0);
  737. END;     { ParensOk }
  738.  
  739.  
  740.  
  741. { ----- This grabs a number from the expression. }
  742. FUNCTION Term (VAR Expr: String; VAR ErrCode: Integer): Real;
  743. VAR
  744.    junk: Integer;
  745.    RVal: Real;
  746.    ch: char;
  747.    tmp: String;
  748. BEGIN
  749.    RVal := 0.0;
  750.    ch := Upcase(Expr[1]);
  751.    IF ch <> Locase(ch) THEN BEGIN
  752.       tmp := '';
  753.       REPEAT
  754.          tmp := tmp + ch;
  755.          Delete(Expr, 1, 1);
  756.          ch := Upcase(Expr[1]);
  757.       UNTIL (ch = Locase(ch)) OR (Length(Expr) = 0);
  758.       IF tmp = 'ABS' THEN
  759.          IF ch = '(' THEN BEGIN
  760.             Delete(Expr, 1, 1);
  761.             RVal := ABS(Eval(Expr, ErrCode))
  762.          END
  763.          ELSE
  764.             ErrCode := 1
  765.       ELSE IF tmp = 'ACOS' THEN
  766.          IF ch = '(' THEN BEGIN
  767.             Delete(Expr, 1, 1);
  768.             RVal := ArcCos(Eval(Expr, ErrCode))
  769.          END
  770.          ELSE
  771.             ErrCode := 1
  772.       ELSE IF tmp = 'ASIN' THEN
  773.          IF ch = '(' THEN BEGIN
  774.             Delete(Expr, 1, 1);
  775.             RVal := ArcSin(Eval(Expr, ErrCode))
  776.          END
  777.          ELSE
  778.             ErrCode := 1
  779.       ELSE IF tmp = 'ATAN' THEN
  780.          IF ch = '(' THEN BEGIN
  781.             Delete(Expr, 1, 1);
  782.             RVal := ARCTAN(Eval(Expr, ErrCode))
  783.          END
  784.          ELSE
  785.             ErrCode := 1
  786.       ELSE IF tmp = 'COS' THEN
  787.          IF ch = '(' THEN BEGIN
  788.             Delete(Expr, 1, 1);
  789.             RVal := COS(Eval(Expr, ErrCode))
  790.          END
  791.          ELSE
  792.             ErrCode := 1
  793.       ELSE IF tmp = 'FRAC' THEN
  794.          IF ch = '(' THEN BEGIN
  795.             Delete(Expr, 1, 1);
  796.             RVal := Eval(Expr, ErrCode);
  797.             RVal := RVal - INT(RVal);
  798.          END
  799.          ELSE
  800.             ErrCode := 1
  801.       ELSE IF tmp = 'INT' THEN
  802.          IF ch = '(' THEN BEGIN
  803.             Delete(Expr, 1, 1);
  804.             RVal := INT(Eval(Expr, ErrCode))
  805.          END
  806.          ELSE
  807.             ErrCode := 1
  808.       ELSE IF tmp = 'LOG' THEN
  809.          IF ch = '(' THEN BEGIN
  810.             Delete(Expr, 1, 1);
  811.             RVal := LOG(Eval(Expr, ErrCode))
  812.          END
  813.          ELSE
  814.             ErrCode := 1
  815.       ELSE IF tmp = 'PI' THEN
  816.          RVal := 3.141593
  817.       ELSE IF tmp = 'SIN' THEN
  818.          IF ch = '(' THEN BEGIN
  819.             Delete(Expr, 1, 1);
  820.             RVal := SIN(Eval(Expr, ErrCode))
  821.          END
  822.          ELSE
  823.             ErrCode := 1
  824.       ELSE IF tmp = 'SQRT' THEN
  825.          IF ch = '(' THEN BEGIN
  826.             Delete(Expr, 1, 1);
  827.             RVal := SQRT(Eval(Expr, ErrCode))
  828.          END
  829.          ELSE
  830.             ErrCode := 1
  831.       ELSE IF tmp = 'TAN' THEN
  832.          IF ch = '(' THEN BEGIN
  833.             Delete(Expr, 1, 1);
  834.             RVal := TAN(Eval(Expr, ErrCode))
  835.          END
  836.          ELSE
  837.             ErrCode := 1
  838.       ELSE
  839.          ErrCode := 3
  840.    END
  841.    ELSE IF IsDigit(Expr) THEN BEGIN
  842.       tmp := '';
  843.       WHILE IsDigit(Expr) DO BEGIN
  844.          tmp := tmp + Expr[1];
  845.          Delete(Expr, 1, 1);
  846.       END;
  847.       Val(tmp, RVal, junk);
  848.    END
  849.    ELSE
  850.       ErrCode := 2;
  851.    Term := RVal;
  852. END;     { Term }
  853.  
  854.  
  855.  
  856. END.     { ExtMath UNIT }
  857.